home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / bind.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  21.7 KB  |  1,025 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     bind.c
  24. */
  25.  
  26. #include "include.h"
  27. #include "varargs.h"
  28.  
  29. struct nil3 { object nil3_self[3]; } three_nils;
  30. struct nil6 { object nil6_self[6]; } six_nils;
  31.  
  32. struct required {
  33.     object    req_var;
  34.     object    req_spp;
  35. };
  36.  
  37. struct optional {
  38.     object    opt_var;
  39.     object    opt_spp;
  40.     object    opt_init;
  41.     object    opt_svar;
  42.     object    opt_svar_spp;
  43. };
  44.  
  45. struct rest {
  46.     object    rest_var;
  47.     object    rest_spp;
  48. };
  49.  
  50. struct keyword {
  51.     object    key_word;
  52.     object    key_var;
  53.     object    key_spp;
  54.     object    key_init;
  55.     object    key_svar;
  56.     object    key_svar_spp;
  57.     object    key_val;
  58.     object    key_svar_val;
  59. };
  60.  
  61. struct aux {
  62.     object    aux_var;
  63.     object    aux_spp;
  64.     object    aux_init;
  65. };
  66.  
  67.  
  68.  
  69. static object temporary;
  70.  
  71. #define    isdeclare(x)    ((x) == Sdeclare)
  72.  
  73. lambda_bind(arg_top)
  74. object *arg_top;
  75. {
  76.     object lambda, lambda_list, body, form, x, ds, vs, v;
  77.     int narg, i, j;
  78.     object *base = vs_base;
  79.     struct required *required;
  80.     int nreq;
  81.     struct optional *optional;
  82.     int nopt;
  83.     struct rest *rest;
  84.     bool rest_flag;
  85.     struct keyword *keyword;
  86.     bool key_flag;
  87.     bool allow_other_keys_flag, other_keys_appeared;
  88.     int nkey;
  89.     struct aux *aux;
  90.     int naux;
  91.     bool special_processed;
  92.     vs_mark;
  93.  
  94.     bds_check;
  95.     lambda = vs_head;
  96.     if (type_of(lambda) != t_cons)
  97.         FEerror("No lambda list.", 0);
  98.     lambda_list = lambda->c.c_car;
  99.     body = lambda->c.c_cdr;
  100.  
  101.     required = (struct required *)vs_top;
  102.     nreq = 0;
  103.     for (;;) {
  104.         if (endp(lambda_list))
  105.             goto REQUIRED_ONLY;
  106.         x = lambda_list->c.c_car;
  107.         lambda_list = lambda_list->c.c_cdr;
  108.         check_symbol(x);
  109.         if (x == ANDallow_other_keys)
  110.             illegal_lambda();
  111.         if (x == ANDoptional) {
  112.             nopt = nkey = naux = 0;
  113.             rest_flag = key_flag = allow_other_keys_flag
  114.             = FALSE;
  115.             goto OPTIONAL;
  116.         }
  117.         if (x == ANDrest) {
  118.             nopt = nkey = naux = 0;
  119.             key_flag = allow_other_keys_flag
  120.             = FALSE;
  121.             goto REST;
  122.         }
  123.         if (x == ANDkey) {
  124.             nopt = nkey = naux = 0;
  125.             rest_flag = allow_other_keys_flag
  126.             = FALSE;
  127.             goto KEYWORD;
  128.         }
  129.         if (x == ANDaux) {
  130.             nopt = nkey = naux = 0;
  131.             rest_flag = key_flag = allow_other_keys_flag
  132.             = FALSE;
  133.             goto AUX_L;
  134.         }
  135.         if ((enum stype)x->s.s_stype == stp_constant)
  136.             FEerror("~S is not a variable.", 1, x);
  137.         vs_push(x);
  138.         vs_push(Cnil);
  139.         nreq++;
  140.     }
  141.  
  142. OPTIONAL:
  143.     optional = (struct optional *)vs_top;
  144.     for (;;  nopt++) {
  145.         if (endp(lambda_list))
  146.             goto SEARCH_DECLARE;
  147.         x = lambda_list->c.c_car;
  148.         lambda_list = lambda_list->c.c_cdr;
  149.         if (type_of(x) == t_cons) {
  150.             check_symbol(x->c.c_car);
  151.             check_var(x->c.c_car);
  152.             vs_push(x->c.c_car);
  153.             x = x->c.c_cdr;
  154.             vs_push(Cnil);
  155.             if (endp(x)) {
  156.                 *(struct nil3 *)vs_top = three_nils;
  157.                 vs_top += 3;
  158.                 continue;
  159.             }
  160.             vs_push(x->c.c_car);
  161.             x = x->c.c_cdr;
  162.             if (endp(x)) {
  163.                 vs_push(Cnil);
  164.                 vs_push(Cnil);
  165.                 continue;
  166.             }
  167.             check_symbol(x->c.c_car);
  168.             check_var(x->c.c_car);
  169.             vs_push(x->c.c_car);
  170.             vs_push(Cnil);
  171.             if (!endp(x->c.c_cdr))
  172.                 illegal_lambda();
  173.         } else {
  174.             check_symbol(x);
  175.             if (x == ANDoptional ||
  176.                 x == ANDallow_other_keys)
  177.                 illegal_lambda();
  178.             if (x == ANDrest)
  179.                 goto REST;
  180.             if (x == ANDkey)
  181.                 goto KEYWORD;
  182.             if (x == ANDaux)
  183.                 goto AUX_L;
  184.             check_var(x);
  185.             vs_push(x);
  186.             *(struct nil6 *)vs_top = six_nils;
  187.             vs_top += 4;
  188.         }
  189.     }
  190.  
  191. REST:
  192.     rest = (struct rest *)vs_top;
  193.     if (endp(lambda_list))
  194.         illegal_lambda();
  195.     check_symbol(lambda_list->c.c_car);
  196.     check_var(lambda_list->c.c_car);
  197.     rest_flag = TRUE;
  198.     vs_push(lambda_list->c.c_car);
  199.     vs_push(Cnil);
  200.     lambda_list = lambda_list->c.c_cdr;
  201.     if (endp(lambda_list))
  202.         goto SEARCH_DECLARE;
  203.     x = lambda_list->c.c_car;
  204.     lambda_list = lambda_list->c.c_cdr;
  205.     check_symbol(x);
  206.     if (x == ANDoptional || x == ANDrest ||
  207.         x == ANDallow_other_keys)
  208.         illegal_lambda();
  209.     if (x == ANDkey)
  210.         goto KEYWORD;
  211.     if (x == ANDaux)
  212.         goto AUX_L;
  213.     illegal_lambda();
  214.  
  215. KEYWORD:
  216.     keyword = (struct keyword *)vs_top;
  217.     key_flag = TRUE;
  218.     for (;;  nkey++) {
  219.         if (endp(lambda_list))
  220.             goto SEARCH_DECLARE;
  221.         x = lambda_list->c.c_car;
  222.         lambda_list = lambda_list->c.c_cdr;
  223.         if (type_of(x) == t_cons) {
  224.             if (type_of(x->c.c_car) == t_cons) {
  225.                 if (!keywordp(x->c.c_car->c.c_car))
  226.                     FEerror("~S is not a keyword.",
  227.                         1, x->c.c_car->c.c_car);
  228.                 vs_push(x->c.c_car->c.c_car);
  229.                 if (endp(x->c.c_car->c.c_cdr))
  230.                     illegal_lambda();
  231.                 check_symbol(x->c.c_car
  232.                           ->c.c_cdr->c.c_car);
  233.                 vs_push(x->c.c_car->c.c_cdr->c.c_car);
  234.                 if (!endp(x->c.c_car->c.c_cdr->c.c_cdr))
  235.                     illegal_lambda();
  236.             } else {
  237.                 check_symbol(x->c.c_car);
  238.                 check_var(x->c.c_car);
  239.                 vs_push(intern(x->c.c_car, keyword_package));
  240.                 vs_push(x->c.c_car);
  241.             }
  242.             vs_push(Cnil);
  243.             x = x->c.c_cdr;
  244.             if (endp(x)) {
  245.                 *(struct nil6 *)vs_top = six_nils;
  246.                 vs_top += 5;
  247.                 continue;
  248.             }
  249.             vs_push(x->c.c_car);
  250.             x = x->c.c_cdr;
  251.             if (endp(x)) {
  252.                 *(struct nil6 *)vs_top = six_nils;
  253.                 vs_top += 4;
  254.                 continue;
  255.             }
  256.             check_symbol(x->c.c_car);
  257.             check_var(x->c.c_car);
  258.             vs_push(x->c.c_car);
  259.             vs_push(Cnil);
  260.             if (!endp(x->c.c_cdr))
  261.                 illegal_lambda();
  262.             vs_push(Cnil);
  263.             vs_push(Cnil);
  264.         } else {
  265.             check_symbol(x);
  266.             if (x == ANDallow_other_keys) {
  267.                 allow_other_keys_flag = TRUE;
  268.                 if (endp(lambda_list))
  269.                     goto SEARCH_DECLARE;
  270.                 x = lambda_list->c.c_car;
  271.                 lambda_list = lambda_list->c.c_cdr;
  272.             }
  273.             if (x == ANDoptional || x == ANDrest ||
  274.                 x == ANDkey || x == ANDallow_other_keys)
  275.                 illegal_lambda();
  276.             if (x == ANDaux)
  277.                 goto AUX_L;
  278.             check_var(x);
  279.             vs_push(intern(x, keyword_package));
  280.             vs_push(x);
  281.             *(struct nil6 *)vs_top = six_nils;
  282.             vs_top += 6;
  283.         }
  284.     }
  285.  
  286. AUX_L:
  287.     aux = (struct aux *)vs_top;
  288.     for (;;  naux++) {
  289.         if (endp(lambda_list))
  290.             goto SEARCH_DECLARE;
  291.         x = lambda_list->c.c_car;
  292.         lambda_list = lambda_list->c.c_cdr;
  293.         if (type_of(x) == t_cons) {
  294.             check_symbol(x->c.c_car);
  295.             check_var(x->c.c_car);
  296.             vs_push(x->c.c_car);
  297.             vs_push(Cnil);
  298.             x = x->c.c_cdr;
  299.             if (endp(x)) {
  300.                 vs_push(Cnil);
  301.                 continue;
  302.             }
  303.             vs_push(x->c.c_car);
  304.             if (!endp(x->c.c_cdr))
  305.                 illegal_lambda();
  306.         } else {
  307.             check_symbol(x);
  308.             if (x == ANDoptional || x == ANDrest ||
  309.                 x == ANDkey || x == ANDallow_other_keys ||
  310.                     x == ANDaux)
  311.                 illegal_lambda();
  312.             check_var(x);
  313.             vs_push(x);
  314.             vs_push(Cnil);
  315.             vs_push(Cnil);
  316.         }
  317.     }
  318.  
  319. SEARCH_DECLARE:
  320.     vs_push(Cnil);
  321.     for (;  !endp(body);  body = body->c.c_cdr) {
  322.         form = body->c.c_car;
  323.  
  324.         /*  MACRO EXPANSION  */
  325.         form = macro_expand(form);
  326.         vs_head = form;
  327.  
  328.         if (type_of(form) == t_string) {
  329.             if (endp(body->c.c_cdr))
  330.                 break;
  331.             continue;
  332.         }
  333.         if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
  334.             break;
  335.         for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
  336.             if (type_of(ds->c.c_car) != t_cons)
  337.                 illegal_declare(form);
  338.             if (ds->c.c_car->c.c_car == Sspecial) {
  339.                 vs = ds->c.c_car->c.c_cdr;
  340.                 for (;  !endp(vs);  vs = vs->c.c_cdr) {
  341.                     v = vs->c.c_car;
  342.                     check_symbol(v);
  343. /**/
  344.  
  345.     special_processed = FALSE;
  346.     for (i = 0;  i < nreq;  i++)
  347.         if (required[i].req_var == v) {
  348.             required[i].req_spp = Ct;
  349.             special_processed = TRUE;
  350.         }
  351.     for (i = 0;  i < nopt;  i++)
  352.         if (optional[i].opt_var == v) {
  353.             optional[i].opt_spp = Ct;
  354.             special_processed = TRUE;
  355.         } else if (optional[i].opt_svar == v) {
  356.             optional[i].opt_svar_spp = Ct;
  357.             special_processed = TRUE;
  358.         }
  359.     if (rest_flag && rest->rest_var == v) {
  360.         rest->rest_spp = Ct;
  361.         special_processed = TRUE;
  362.     }
  363.     for (i = 0;  i < nkey;  i++)
  364.         if (keyword[i].key_var == v) {
  365.             keyword[i].key_spp = Ct;
  366.             special_processed = TRUE;
  367.         } else if (keyword[i].key_svar == v) {
  368.             keyword[i].key_svar_spp = Ct;
  369.             special_processed = TRUE;
  370.         }
  371.     for (i = 0;  i < naux;  i++)
  372.         if (aux[i].aux_var == v) {
  373.             aux[i].aux_spp = Ct;
  374.             special_processed = TRUE;
  375.         }
  376.     if (special_processed)
  377.         continue;
  378.     /*  lex_special_bind(v);  */
  379.     temporary = MMcons(v, Cnil);
  380.     lex_env[0] = MMcons(temporary, lex_env[0]);
  381.  
  382. /**/
  383.                 }
  384.             }
  385.         }
  386.     }
  387.  
  388.     narg = arg_top - base;
  389.     if (narg < nreq) {
  390.         if (nopt == 0 && !rest_flag && !key_flag) {
  391.             vs_base = base;
  392.             vs_top = arg_top;
  393.             check_arg_failed(nreq);
  394.         }
  395.         FEtoo_few_arguments(base, arg_top);
  396.     }
  397.     if (!rest_flag && !key_flag && narg > nreq+nopt) {
  398.         if (nopt == 0) {
  399.             vs_base = base;
  400.             vs_top = arg_top;
  401.             check_arg_failed(nreq);
  402.         }
  403.         FEtoo_many_arguments(base, arg_top);
  404.     }
  405.     for (i = 0;  i < nreq;  i++)
  406.         bind_var(required[i].req_var,
  407.              base[i],
  408.              required[i].req_spp);
  409.     for (i = 0;  i < nopt;  i++)
  410.         if (nreq+i < narg) {
  411.             bind_var(optional[i].opt_var,
  412.                  base[nreq+i],
  413.                  optional[i].opt_spp);
  414.             if (optional[i].opt_svar != Cnil)
  415.                 bind_var(optional[i].opt_svar,
  416.                      Ct,
  417.                      optional[i].opt_svar_spp);
  418.         } else {
  419.             eval_assign(temporary, optional[i].opt_init);
  420.             bind_var(optional[i].opt_var,
  421.                  temporary,
  422.                  optional[i].opt_spp);
  423.             if (optional[i].opt_svar != Cnil)
  424.                 bind_var(optional[i].opt_svar,
  425.                      Cnil,
  426.                      optional[i].opt_svar_spp);
  427.         }
  428.     if (rest_flag) {
  429.         vs_push(Cnil);
  430.         for (i = narg, j = nreq+nopt;  --i >= j;  )
  431.             vs_head = make_cons(base[i], vs_head);
  432.         bind_var(rest->rest_var, vs_head, rest->rest_spp);
  433.     }
  434.     if (key_flag) {
  435.         i = narg - nreq - nopt;
  436.         if (i >= 0 && i%2 != 0)
  437.             FEerror("Keyword values are missing.", 0);
  438.         other_keys_appeared = FALSE;
  439.         for (i = nreq + nopt;  i < narg;  i += 2) {
  440.             if (!keywordp(base[i]))
  441.                 FEerror("~S is not a keyword.",
  442.                     1, base[i]);
  443.             if (base[i] == Kallow_other_keys &&
  444.                 base[i+1] != Cnil)
  445.                 allow_other_keys_flag = TRUE;
  446.             for (j = 0;  j < nkey;  j++) {
  447.                 if (keyword[j].key_word == base[i]) {
  448.                     if (keyword[j].key_svar_val
  449.                         != Cnil)
  450.                         goto NEXT_ARG;
  451.                     keyword[j].key_val
  452.                     = base[i+1];
  453.                     keyword[j].key_svar_val
  454.                     = Ct;
  455.                     goto NEXT_ARG;
  456.                 }
  457.             }
  458.             other_keys_appeared = TRUE;
  459.  
  460.         NEXT_ARG:
  461.             continue;
  462.         }
  463.         if (other_keys_appeared && !allow_other_keys_flag)
  464.             FEerror("Other-keys are not allowed.", 0);
  465.     }
  466.     for (i = 0;  i < nkey;  i++)
  467.         if (keyword[i].key_svar_val != Cnil) {
  468.             bind_var(keyword[i].key_var,
  469.                  keyword[i].key_val,
  470.                  keyword[i].key_spp);
  471.             if (keyword[i].key_svar != Cnil)
  472.                 bind_var(keyword[i].key_svar,
  473.                      keyword[i].key_svar_val,
  474.                      keyword[i].key_svar_spp);
  475.         } else {
  476.             eval_assign(temporary, keyword[i].key_init);
  477.             bind_var(keyword[i].key_var,
  478.                  temporary,
  479.                  keyword[i].key_spp);
  480.             if (keyword[i].key_svar != Cnil)
  481.                 bind_var(keyword[i].key_svar,
  482.                      keyword[i].key_svar_val,
  483.                      keyword[i].key_svar_spp);
  484.         }
  485.     for (i = 0;  i < naux;  i++) {
  486.         eval_assign(temporary, aux[i].aux_init);
  487.         bind_var(aux[i].aux_var, temporary, aux[i].aux_spp);
  488.     }
  489.     if (type_of(body) != t_cons || body->c.c_car == form) {
  490.         vs_reset;
  491.         vs_head = body;
  492.     } else {
  493.         body = make_cons(form, body->c.c_cdr);
  494.         vs_reset;
  495.         vs_head = body;
  496.     }
  497.     return;
  498.  
  499. REQUIRED_ONLY:
  500.     vs_push(Cnil);
  501.     for (;  !endp(body);  body = body->c.c_cdr) {
  502.         form = body->c.c_car;
  503.  
  504.         /*  MACRO EXPANSION  */
  505.         vs_head = form = macro_expand(form);
  506.  
  507.         if (type_of(form) == t_string) {
  508.             if (endp(body->c.c_cdr))
  509.                 break;
  510.             continue;
  511.         }
  512.         if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
  513.             break;
  514.         for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
  515.             if (type_of(ds->c.c_car) != t_cons)
  516.                 illegal_declare(form);
  517.             if (ds->c.c_car->c.c_car == Sspecial) {
  518.                 vs = ds->c.c_car->c.c_cdr;
  519.                 for (;  !endp(vs);  vs = vs->c.c_cdr) {
  520.                     v = vs->c.c_car;
  521.                     check_symbol(v);
  522. /**/
  523.  
  524.     special_processed = FALSE;
  525.     for (i = 0;  i < nreq;  i++)
  526.         if (required[i].req_var == v) {
  527.             required[i].req_spp = Ct;
  528.             special_processed = TRUE;
  529.         }
  530.     if (special_processed)
  531.         continue;
  532.     /*  lex_special_bind(v);  */
  533.     temporary = MMcons(v, Cnil);
  534.     lex_env[0] = MMcons(temporary, lex_env[0]);
  535.  
  536. /**/
  537.                 }
  538.             }
  539.         }
  540.     }
  541.  
  542.     narg = arg_top - base;
  543.     if (narg != nreq) {
  544.         vs_base = base;
  545.         vs_top = arg_top;
  546.         check_arg_failed(nreq);
  547.     }
  548.     for (i = 0;  i < nreq;  i++)
  549.         bind_var(required[i].req_var,
  550.              base[i],
  551.              required[i].req_spp);
  552.     if (type_of(body) != t_cons || body->c.c_car == form) {
  553.         vs_reset;
  554.         vs_head = body;
  555.     } else {
  556.         body = make_cons(form, body->c.c_cdr);
  557.         vs_reset;
  558.         vs_head = body;
  559.     }
  560. }
  561.  
  562. bind_var(var, val, spp)
  563. object var, val, spp;
  564. {
  565.     vs_mark;
  566.  
  567.     switch (var->s.s_stype) {
  568.     case stp_constant:
  569.         FEerror("Cannot bind the constant ~S.", 1, var);
  570.  
  571.     case stp_special:
  572.         bds_bind(var, val);
  573.         break;
  574.  
  575.     default:
  576.         if (spp != Cnil) {
  577.             /*  lex_special_bind(var);  */
  578.             temporary = MMcons(var, Cnil);
  579.             lex_env[0] = MMcons(temporary, lex_env[0]);
  580.             bds_bind(var, val);
  581.         } else {
  582.             /*  lex_local_bind(var, val);  */
  583.             temporary = MMcons(val, Cnil);
  584.             temporary = MMcons(var, temporary);
  585.             lex_env[0] = MMcons(temporary, lex_env[0]);
  586.         }
  587.         break;
  588.     }
  589.     vs_reset;
  590. }
  591.  
  592. illegal_lambda()
  593. {
  594.     FEerror("Illegal lambda expression.", 0);
  595. }
  596.  
  597. /*
  598. struct bind_temp {
  599.     object    bt_var;
  600.     object    bt_spp;
  601.     object    bt_init;
  602.     object    bt_aux;
  603. };
  604. */
  605.  
  606. object
  607. find_special(body, start, end)
  608. object body;
  609. struct bind_temp *start, *end;
  610. {
  611.     object form;
  612.     object ds, vs, v;
  613.     struct bind_temp *bt;
  614.     bool special_processed;
  615.     vs_mark;
  616.  
  617.     vs_push(Cnil);
  618.     for (;  !endp(body);  body = body->c.c_cdr) {
  619.         form = body->c.c_car;
  620.  
  621.         /*  MACRO EXPANSION  */
  622.         form = macro_expand(form);
  623.         vs_head = form;
  624.  
  625.         if (type_of(form) == t_string) {
  626.             if (endp(body->c.c_cdr))
  627.                 break;
  628.             continue;
  629.         }
  630.         if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
  631.             break;
  632.         for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
  633.             if (type_of(ds->c.c_car) != t_cons)
  634.                 illegal_declare(form);
  635.             if (ds->c.c_car->c.c_car == Sspecial) {
  636.                 vs = ds->c.c_car->c.c_cdr;
  637.                 for (;  !endp(vs);  vs = vs->c.c_cdr) {
  638.                     v = vs->c.c_car;
  639.                     check_symbol(v);
  640. /**/
  641.     special_processed = FALSE;
  642.     for (bt = start;  bt < end;  bt++)
  643.         if (bt->bt_var == v) {
  644.             bt->bt_spp = Ct;
  645.             special_processed = TRUE;
  646.         }
  647.     if (special_processed)
  648.         continue;
  649.     /*  lex_special_bind(v);  */
  650.     temporary = MMcons(v, Cnil);
  651.     lex_env[0] = MMcons(temporary, lex_env[0]);
  652. /**/
  653.                 }
  654.             }
  655.         }
  656.     }
  657.  
  658.     if (body != Cnil && body->c.c_car != form)
  659.         body = make_cons(form, body->c.c_cdr);
  660.     vs_reset;
  661.     return(body);
  662. }
  663.  
  664. object
  665. let_bind(body, start, end)
  666. object body;
  667. struct bind_temp *start, *end;
  668. {
  669.     struct bind_temp *bt;
  670.  
  671.     bds_check;
  672.     vs_push(find_special(body, start, end));
  673.     for (bt = start;  bt < end;  bt++) {
  674.         eval_assign(bt->bt_init, bt->bt_init);
  675.     }
  676.     for (bt = start;  bt < end;  bt++) {
  677.         bind_var(bt->bt_var, bt->bt_init, bt->bt_spp);
  678.     }
  679.     return(vs_pop);
  680. }
  681.  
  682. object
  683. letA_bind(body, start, end)
  684. object body;
  685. struct bind_temp *start, *end;
  686. {
  687.     struct bind_temp *bt;
  688.     
  689.     bds_check;
  690.     vs_push(find_special(body, start, end));
  691.     for (bt = start;  bt < end;  bt++) {
  692.         eval_assign(bt->bt_init, bt->bt_init);
  693.         bind_var(bt->bt_var, bt->bt_init, bt->bt_spp);
  694.     }
  695.     return(vs_pop);
  696. }
  697.  
  698.  
  699. #ifdef MV
  700.  
  701. #endif
  702.  
  703. #define    NOT_YET        10
  704. #define    FOUND        11
  705. #define    NOT_KEYWORD    1
  706.  
  707. parse_key(base, rest, allow_other_keys, n, va_alist)
  708. object *base;
  709. bool rest, allow_other_keys;
  710. register int n;
  711. va_dcl
  712. {       va_list ap;
  713.     object other_key = OBJNULL;
  714.     int narg, error_flag = 0;
  715.     object *v, k, *top;
  716.     register int i;
  717.  
  718.     narg = vs_top - base;
  719.     if (narg <= 0) {
  720.         if (rest) {
  721.             base[0] = Cnil;
  722.             base++;
  723.         }
  724.         top = base + n;
  725.         for (i = 0;  i < n;  i++) {
  726.             base[i] = Cnil;
  727.             top[i] = Cnil;
  728.         }
  729.         return;
  730.     }
  731.     if (narg%2 != 0)
  732.         FEerror("Odd number of arguments for keywords.", 0);
  733.     if (narg == 2) {
  734.         k = base[0];
  735.         if (!keywordp(k))
  736.             FEerror("~S is not a keyword.", 1, k);
  737.         if (k == Kallow_other_keys && base[1] != Cnil)
  738.             allow_other_keys = TRUE;
  739.         temporary = base[1];
  740.         if (rest)
  741.             base++;
  742.         top = base + n;
  743.         other_key = k;
  744.         va_start(ap);
  745.         for (i = 0;  i < n;  i++) {
  746.             
  747.             if (va_arg(ap,object) == k) {
  748.                 base[i] = temporary;
  749.                 top[i] = Ct;
  750.                 other_key = OBJNULL;
  751.             } else {
  752.                 base[i] = Cnil;
  753.                 top[i] = Cnil;
  754.             }
  755.         }
  756.         va_end(ap);
  757.         if (rest) {
  758.             temporary = make_cons(temporary, Cnil);
  759.             base[-1] = make_cons(k, temporary);
  760.         }
  761.         if (other_key != OBJNULL && !allow_other_keys)
  762.             FEerror("The keyword ~S is not allowed.",1,other_key);
  763.         return;
  764.     }
  765.     va_start(ap);
  766.     for (i = 0;  i < n;  i++) {
  767.         k = va_arg(ap,object);
  768.         k->s.s_stype = NOT_YET;
  769.         k->s.s_dbind = Cnil;
  770.     }
  771.     va_end(ap);
  772.     for (v = base;  v < vs_top;  v += 2) {
  773.         k = v[0];
  774.         if (!keywordp(k)) {
  775.             error_flag = NOT_KEYWORD;
  776.             other_key = k;
  777.             continue;
  778.         }
  779.         if (k->s.s_stype == NOT_YET) {
  780.             k->s.s_dbind = v[1];
  781.             k->s.s_stype = FOUND;
  782.         } else if (k->s.s_stype == FOUND) {
  783.             ;
  784.         } else if (other_key == OBJNULL)
  785.             other_key = k;
  786.         if (k == Kallow_other_keys && v[1] != Cnil)
  787.             allow_other_keys = TRUE;
  788.     }
  789.     if (rest) {
  790.         top = vs_top;
  791.         vs_push(Cnil);
  792.         base++;
  793.         while (base < vs_top)
  794.             stack_cons();
  795.         vs_top = top;
  796.     }
  797.     top = base + n;
  798.     va_start(ap);
  799.     for (i = 0;  i < n;  i++) {
  800.         k = va_arg(ap,object);
  801.         base[i] = k->s.s_dbind;
  802.         top[i] = k->s.s_stype == FOUND ? Ct : Cnil;
  803.         k->s.s_dbind = k;
  804.         k->s.s_stype = (short)stp_constant;
  805.     }
  806.     va_end(ap);
  807.     if (error_flag == NOT_KEYWORD)
  808.         FEerror("~S is not a keyword.", 1, other_key);
  809.     if (other_key != OBJNULL && !allow_other_keys)
  810.         FEerror("The keyword ~S is not allowed.", 1, other_key);
  811. }
  812.  
  813. check_other_key(l, n, va_alist)
  814. object l;
  815. int n;
  816. va_dcl
  817. {
  818.     va_list ap;
  819.     object other_key = OBJNULL;
  820.     object k;
  821.     int i;
  822.     bool allow_other_keys = FALSE;
  823.  
  824.     for (;  !endp(l);  l = l->c.c_cdr->c.c_cdr) {
  825.         k = l->c.c_car;
  826.         if (!keywordp(k))
  827.             FEerror("~S is not a keyword.", 1, k);
  828.         if (endp(l->c.c_cdr))
  829.             FEerror("Odd number of arguments for keywords.", 0);
  830.         if (k == Kallow_other_keys && l->c.c_cdr->c.c_car != Cnil) {
  831.             allow_other_keys = TRUE;
  832.         } else {register object *loc;
  833.             char buf [100];
  834.             bzero(buf,n);
  835.             va_start(ap);
  836.             for (i = 0;  i < n;  i++)
  837.               { if (va_arg(ap,object) == k &&
  838.                 buf[i] ==0) {buf[i]=1; break;}}
  839.             va_end(ap);
  840.             if (i >= n) other_key = k;
  841.         }
  842.     }
  843.     if (other_key != OBJNULL && !allow_other_keys)
  844.         FEerror("The keyword ~S is not allowed or is duplicated.",
  845.             1, other_key);
  846. }
  847.  
  848.  
  849. struct key {short n,allow_other_keys;
  850.         iobject *defaults;
  851.         iobject keys[1];
  852.        };
  853.  
  854.  
  855. object Cstd_key_defaults[15]={Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,
  856.                 Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil};
  857.  
  858. parse_key_new(n,base,keys,ap)
  859.      int n;
  860.      object *base;
  861.      struct key *keys;
  862.      va_list ap;
  863. {object *new;
  864.  COERCE_VA_LIST(new,ap,n);
  865.  
  866.  /* from here down identical to parse_key_rest */
  867.  new = new + n ;
  868.   {int j=keys->n;
  869.    object *p= (object *)(keys->defaults);
  870.    while (--j >=0) base[j]=p[j];
  871.  }
  872.  {if (n==0){ return;}
  873.  {int allow = keys->allow_other_keys;
  874.   object k;
  875.  top:
  876.   while (n>=2)
  877.     {int i= keys->n;
  878.      iobject *ke=keys->keys ;
  879.      new = new -2;
  880.      k = *new;
  881.      while(--i >= 0)
  882.        {if ((*(ke++)).o == k)
  883.       {base[i]= new[1];
  884.        n=n-2;
  885.        goto top;
  886.      }}
  887.      /* the key is a new one */
  888.      if (allow  )
  889.        {
  890.      n=n-2;
  891.       }
  892.      else
  893.        {int m = n -2;
  894.     object *p = new;
  895.     while (m >= 0)
  896.       {if (*p == Kallow_other_keys)
  897.          { allow = (p[1] !=Cnil) ; break;}
  898.        p -= 2;
  899.        m -= 2;}
  900.     if (allow) n = n -2 ; else goto error;}
  901.    }
  902.   if (n!=0) FEerror("Odd number of keys");
  903.   return 0;
  904.  error:
  905.   FEerror("Unrecognized key ~a",1,k);
  906. }}}
  907.  
  908. parse_key_rest(rest,n,base,keys,ap)
  909.      int n;
  910.      object *base;
  911.      struct key *keys;
  912.      va_list ap;
  913.      object rest;
  914. {object *new;
  915.  COERCE_VA_LIST(new,ap,n);
  916.  
  917.  /* copy the rest arg */
  918.  {object *p = new;
  919.   int m = n;
  920.   while (--m >= 0)
  921.     {rest->c.c_car = *p++;
  922.      rest = rest->c.c_cdr;}}
  923.     
  924.  new = new + n ;
  925.   {int j=keys->n;
  926.    object *p= (object *)(keys->defaults);
  927.    while (--j >=0) base[j]=p[j];
  928.  }
  929.  {if (n==0){ return;}
  930.  {int allow = keys->allow_other_keys;
  931.   object k;
  932.  top:
  933.   while (n>=2)
  934.     {int i= keys->n;
  935.      iobject *ke=keys->keys ;
  936.      new = new -2;
  937.      k = *new;
  938.      while(--i >= 0)
  939.        {if ((*(ke++)).o == k)
  940.       {base[i]= new[1];
  941.        n=n-2;
  942.        goto top;
  943.      }}
  944.      /* the key is a new one */
  945.      if (allow)
  946.        {
  947.      n=n-2;
  948.       }
  949.      else
  950.        {int m = n -2;
  951.     object *p = new;
  952.     while (m >= 0)
  953.       {if (*p == Kallow_other_keys)
  954.          { allow = (p[1] !=Cnil) ; break;}
  955.        p -= 2;
  956.        m -= 2;}
  957.     if (allow) n = n -2 ; else goto error;}
  958.  
  959.    }
  960.   if (n!=0) FEerror("Odd number of keys");
  961.   return 0;
  962.  error:
  963.   FEerror("Unrecognized key ~a",1,k);
  964. }}}
  965.  
  966.   
  967. set_key_struct(ks,data)
  968.      object data;
  969.      struct key *ks;
  970. {int i=ks->n;
  971.  while (--i >=0)
  972.    {ks->keys[i].o =   data->cfd.cfd_self[ ks->keys[i].i ];
  973.     if (ks->defaults != (iobject *)Cstd_key_defaults)
  974.      {int m=ks->defaults[i].i;
  975.         ks->defaults[i].o=
  976.       (m==-2 ? Cnil :
  977.        m==-1 ? (object)0 :
  978.        data->cfd.cfd_self[m]);}
  979. }}
  980.  
  981. #undef AUX
  982.  
  983. init_bind()
  984. {
  985.     ANDoptional = make_ordinary("&OPTIONAL");
  986.     enter_mark_origin(&ANDoptional);
  987.     ANDrest = make_ordinary("&REST");
  988.     enter_mark_origin(&ANDrest);
  989.     ANDkey = make_ordinary("&KEY");
  990.     enter_mark_origin(&ANDkey);
  991.     ANDallow_other_keys = make_ordinary("&ALLOW-OTHER-KEYS");
  992.     enter_mark_origin(&ANDallow_other_keys);
  993.     ANDaux = make_ordinary("&AUX");
  994.     enter_mark_origin(&ANDaux);
  995.  
  996.     make_constant("LAMBDA-LIST-KEYWORDS",
  997.     make_cons(ANDoptional,
  998.     make_cons(ANDrest,
  999.     make_cons(ANDkey,
  1000.     make_cons(ANDallow_other_keys,
  1001.     make_cons(ANDaux,
  1002.     make_cons(make_ordinary("&WHOLE"),
  1003.     make_cons(make_ordinary("&ENVIRONMENT"),
  1004.     make_cons(make_ordinary("&BODY"), Cnil)))))))));
  1005.  
  1006.     make_constant("LAMBDA-PARAMETERS-LIMIT",
  1007.               make_fixnum(64));
  1008.  
  1009.     Kallow_other_keys = make_keyword("ALLOW-OTHER-KEYS");
  1010.  
  1011.     temporary = Cnil;
  1012.     enter_mark_origin(&temporary);
  1013.  
  1014.     three_nils.nil3_self[0] = Cnil;
  1015.     three_nils.nil3_self[1] = Cnil;
  1016.     three_nils.nil3_self[2] = Cnil;
  1017.  
  1018.     six_nils.nil6_self[0] = Cnil;
  1019.     six_nils.nil6_self[1] = Cnil;
  1020.     six_nils.nil6_self[2] = Cnil;
  1021.     six_nils.nil6_self[3] = Cnil;
  1022.     six_nils.nil6_self[4] = Cnil;
  1023.     six_nils.nil6_self[5] = Cnil;
  1024. }
  1025.